Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH3/SRC/TOGRAY.FRM

Text File | 1996-01-24 | 6KB | 219 lines

VERSION 4.00
Begin VB.Form ToGrayForm
   Caption         =   "PalEdit"
   ClientHeight    =   2550
   ClientLeft      =   2595
   ClientTop       =   2265
   ClientWidth     =   3150
   Height          =   2955
   Left            =   2535
   LinkTopic       =   "Form1"
   ScaleHeight     =   170.439
   ScaleMode       =   0  'User
   ScaleWidth      =   210
   Top             =   1920
   Visible         =   0   'False
   Width           =   3270
   Begin VB.PictureBox ImagePict
      AutoRedraw      =   -1  'True
      Height          =   2535
      Left            =   0
      Picture         =   "ToGray.frx":0000
      ScaleHeight     =   165
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   205
      TabIndex        =   0
      Top             =   0
      Width           =   3135
   End
End
Attribute VB_Name = "ToGrayForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Const SysPalSize = 256
Const StaticColor1 = 9
Const StaticColor2 = 246

Dim LogicalPalette As Integer
' ***********************************************
' Load the ImagePict palette so its entries
' match the system entries.
' ***********************************************
Sub LoadLogicalPalette()
Dim palentry(0 To 255) As PALETTEENTRY
Dim blanked(0 To 255) As PALETTEENTRY
Dim i As Integer

    ' Save the logical pallette handle.
    LogicalPalette = ImagePict.Picture.hPal

    ' Make sure ImagePict has the foreground palette.
    i = RealizePalette(ImagePict.hdc)

    ' Give the system a chance to catch up.
    DoEvents

    ' Make the logical palette as big as possible.
    If ResizePalette(LogicalPalette, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If

    ' Get the system palette entries.
    i = GetSystemPaletteEntries(ImagePict.hdc, 0, SysPalSize, palentry(0))

    ' Blank the non-static colors.
    For i = 0 To StaticColor1
        blanked(i) = palentry(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With blanked(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        blanked(i) = palentry(i)
    Next i
    i = SetPaletteEntries(LogicalPalette, 0, SysPalSize, blanked(0))

    ' Insert the non-static colors.
    For i = StaticColor1 + 1 To StaticColor2 - 1
        palentry(i).peFlags = PC_NOCOLLAPSE
    Next i
    i = SetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))

    ' Realize the new palette values.
    i = RealizePalette(ImagePict.hdc)
End Sub

' ***********************************************
' Load the indicated file and prepare to work
' with its palette.
' ***********************************************
Sub LoadImagePict(fname As String)
    On Error GoTo LoadFileError
    ImagePict.Picture = LoadPicture(fname)
    Exit Sub

LoadFileError:
    Beep
    MsgBox "Error loading file " & fname & "." & _
        vbCrLf & Error$
    Exit Sub
End Sub


' ***********************************************
' 1. Make sure we can handle palettes.
' 2. Find out how big the system palette is and how
' many static colors there are.
' 3. Load and display the system palette.
' ***********************************************
Private Sub Form_Load()
Dim cmd As String
Dim sp As Integer
Dim infile As String
Dim outfile As String

    ' Make sure the screen supports palettes.
    If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
        Beep
        MsgBox "This monitor does not support palettes.", _
            vbCritical
        End
    End If

    ' Get the input and output file names.
    cmd = Trim$(Command)
    If cmd = "" Then GoTo Usage

    sp = InStr(cmd, " ")
    If sp = 0 Then
        infile = cmd
    Else
        infile = Left$(cmd, sp - 1)
        If sp < Len(cmd) Then _
            outfile = Trim$(Mid$(cmd, sp + 1))
    End If
    If outfile = "" Then outfile = infile

    ' RealizePalette doesn't work unless the
    ' picture is visible.
    Me.Show

    ' Load image, convert, and save the image.
    LoadImagePict infile
    LoadLogicalPalette
    ConvertToGrays
    SaveImagePict outfile

    End

Usage:
    Beep
    MsgBox "Usage: ToGray infile [outfile]", vbCritical
    End
End Sub

' ***********************************************
' Save the picture in the indicated file.
' ***********************************************
Sub SaveImagePict(fname As String)
    On Error GoTo SaveError
    SavePicture ImagePict.Picture, fname
    Exit Sub

SaveError:
    Beep
    MsgBox "Error saving picture in file " & _
        fname & "." & vbCrLf & vbCrLf & _
        Error$, , vbExclamation
    Exit Sub
End Sub
' ***********************************************
' Replace colors with appropriate grays.
' ***********************************************
Private Sub ConvertToGrays()
Dim palentry(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim clr As Integer

    ' Get the current color values.
    i = GetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))

    ' Fill in the nearest shades.
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With palentry(i)
            clr = (CInt(.peRed) + .peGreen + .peBlue) / 3
            .peRed = clr
            .peGreen = clr
            .peBlue = clr
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    If SetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1)) = 0 Then
        Beep
        MsgBox "Error resetting colors.", , vbExclamation
        Exit Sub
    End If
    i = RealizePalette(ImagePict.hdc)
End Sub

' ************************************************
' Make the image as big as possible.
' (This is really only useful during debugging
' since the form is normally not visible.)
' ************************************************
Private Sub Form_Resize()
    ImagePict.Move 0, 0, ScaleWidth, ScaleHeight
End Sub